#
# coloured petri net implementation
# alpha version, API and features might change
#
# Copyright (c) 2002 Torvald Riegel. All rights reserved. This program is
# free software; you can redistribute it and/or modify it under the same
# terms as Perl itself.
#

package PetriNet::Coloured;

use strict;
use Carp;
use PetriNet::Coloured::Place;
use PetriNet::Coloured::Transition;
use PetriNet::Coloured::Transition::ArcIn;



sub new {
    my $type = shift;
    my $self = bless {
                      places => {},
                      placesInv => {},  # inverse: place_obj -> name
                      transitions => {},
                      placeTransitionRel => {},
                      transitionExecuteQueue => [],
                     }, $type;
    return $self;
}


#
# clearing the net
#
sub clearNet {
    my $self = shift;
    foreach (keys %{$self->{places}}) {
        $self->removePlace($_);
    }
    $self->{transitions} = {};
}


#
# place accessors
#
sub setPlace {
    my $self = shift;
    while (@_) {
        my ($name, $place) = (shift, shift);
        $self->{places}->{$name} = $place;
        $self->{placesInv}->{$place} = $name;
        $place->setNet($self);
    }
}

sub getPlace {
    my ($self, $place) = @_;
    croak "no such place" unless $self->existsPlace($place);
    return $self->{places}->{$place};
}

sub removePlace {
    my ($self, $place) = @_;
    croak "no such place" unless $self->existsPlace($place);
    $self->{places}->{$place}->setNet(undef);
    delete $self->{placesInv}->{$self->{places}->{$place}};
    delete $self->{places}->{$place};
    carp "linked transitions left: ".
      join(',', @{$self->{placeTransitionRel}->{$place}})
      if @{$self->{placeTransitionRel}->{$place}};
    delete $self->{placeTransitionRel}->{$place};
}

sub existsPlace {
    my ($self, $place) = @_;
    return exists $self->{places}->{$place};
}


#
# transition accessors
#
sub setTransition {
    my $self = shift;
    while (@_) {
        my ($name, $transition) = (shift, shift);
        $self->{transitions}->{$name} = $transition;
        $transition->setNet($self);
        foreach ($transition->getInputPlaces()) {
            # at most 1 arc from a place to a transition
            push @{$self->{placeTransitionRel}->{$_}}, $name;
        }
    }
}

sub removeTransition {
    my ($self, $transition) = (shift, shift);
    foreach (keys %{$self->{transitions}->{$transition}->getInputPlaces()}) {
        @{$self->{placeTransitionRel}->{$_}} = grep ($_ ne $transition,
          @{$self->{placeTransitionRel}->{$_}});
    }
    delete $self->{transitions}->{$transition};
}

sub existsTransition {
    my ($self, $trans) = @_;
    return exists $self->{transitions}->{$trans}
}


#
# token notifications
#
# params: ref to/name of place, token ids
sub tokenAdded {
    my ($self, $place) = (shift, shift);
    $place = $self->{placesInv}->{$place}
      if UNIVERSAL::isa($place, 'PetriNet::Coloured::Place');
    foreach (@{$self->{placeTransitionRel}->{$place}}) {
        $self->{transitions}->{$_}->tokenAdded($place, @_);
    }
}

sub tokenRemoved {
    my ($self, $place) = (shift, shift);
    $place = $self->{placesInv}->{$place}
      if UNIVERSAL::isa($place, 'PetriNet::Coloured::Place');
    foreach (@{$self->{placeTransitionRel}->{$place}}) {
        $self->{transitions}->{$_}->tokenRemoved($place, @_);
    }
}



# tries to execute steps.
# params: maxsteps=1
# returns: true if there could be more enabled steps
sub executeSteps {
    my ($self, $maxsteps) = @_;
    $maxsteps = 1 unless $maxsteps;
    my $transitions_tried = 0;
    my $noSteps = 0;
    while ($maxsteps and $transitions_tried < keys %{$self->{transitions}}) {
        # provides a new transition ordering if needed (round robin)
        unless (@{$self->{transitionExecuteQueue}}) {
            push(@{$self->{transitionExecuteQueue}},
                 keys %{$self->{transitions}} );
        }
        $transitions_tried++;
        # let the transition execute one step
        if ($self->{transitions}->{shift @{$self->{transitionExecuteQueue}}}
            ->executeStep()) {
            $maxsteps--;
        }
        if ($maxsteps) {
            # noSteps state if all transitions tried and $maxsteps left
            $noSteps = 1 if $transitions_tried == keys %{$self->{transitions}};
        }
    }
    # TODO return no_steps state ?
    return !$noSteps;
}




sub buildNet {
    my ($self, $trans) = @_;
    $self->clearNet();

    foreach my $tn (keys %$trans) {
        my $t = PetriNet::Coloured::Transition->new();
        my $td = $trans->{$tn};
        # arcs in, single
        my %in;
        foreach (keys %{$td->{single}}) {
             $in{$_} = PetriNet::Coloured::Transition::ArcIn::Single->new
              ( $td->{single}->{$_} );
        }
        # arcs in
        foreach (keys %in) {
            $self->setPlace($_, PetriNet::Coloured::Place->new())
              unless $self->existsPlace($_);
            $t->setArcIn($_, $in{$_});
        }
        # arcs out
        foreach (keys %{$td->{out}}) {
            $self->setPlace($_, PetriNet::Coloured::Place->new())
              unless $self->existsPlace($_);
            $t->setArcOut($_, $td->{out}->{$_});
        }
        # guard
        $t->setGuard($td->{guard});
        # code
        $t->setCode($td->{code});
        # update assoications
        $t->setNet($self);
        $self->setTransition($tn, $t);
    }
}

sub initNet {
}






1;
